perm filename CYCDRI.PRT[4,LMM] blob sn#037527 filedate 1973-04-23 generic text, type T, neo UTF8
  (DEFPROP CYCDRIFNS
           (CYCDRIFNS SLOPE YINTCP CONCT CLCINTA GEQ OUTNDS SETSCALE 
                      POSLABEL POS SCALX SCALE SCALY LINE XDRAW LINE2)
           VALUE)
  (DEFPROP SLOPE (LAMBDA (X1 X2 Y1 Y2)
                         (CONS (DIFFERENCE X1 X2)
                               (DIFFERENCE Y1 Y2)))
           EXPR)
  (DEFPROP YINTCP (LAMBDA (X1 X2 Y1 Y2)
                          (CONS (DIFFERENCE (TIMES Y1 X2)
                                            (TIMES X1 Y2))
                                (DIFFERENCE X2 X1)))
           EXPR)
  (DEFPROP CONCT (LAMBDA (X Y)
                         (OR (EQ (CAAR Y)
                                 (CAAR X))
                             (EQ (CAAR Y)
                                 (CDAR X))
                             (EQ (CDAR Y)
                                 (CAAR X))
                             (EQ (CDAR Y)
                                 (CDAR X))))
           EXPR)
  (DEFPROP CLCINTA (LAMBDA
             (X X1 X2)
             (NOT (MINUSP (TIMES (DIFFERENCE (CAR X)
                                             (TIMES X1 (CDR X)))
                                 (DIFFERENCE (CAR X)
                                             (TIMES X2 (CDR X)))))))
           EXPR)
  (DEFPROP GEQ (LAMBDA (X Y)
                       (NOT (LESSP X Y)))
           EXPR)
  (DEFPROP OUTNDS
           (LAMBDA
             NIL
             (PROG (I)
                   (SETSCALE 10.0 20.0 10.0 20.0)
                   (INITDRAW)
                   (POSLABEL 13.0 13.0 TITLE)
                   (FOR I := (1.0 NMX)
                        WHEN
                        (NOT (ZEROP (NODE I)))
                        AS NEW LL IS (CDR (ASSOC2 I LABELL))
                        DO
                        (POSLABEL (NODE I)
                                  (NODE (PLUS I 20.0))
                                  (COND (LL LL)
                                        (T I))))
                   (FOR NEW LIN IN (CAR (LAST STACK))
                        DO
                        (LINE2 (CADR LIN)
                               (NODE (CAAR LIN))
                               (NODE (PLUS (CAAR LIN)
                                           20.0))
                               (NODE (CDAR LIN))
                               (NODE (PLUS (CDAR LIN)
                                           20.0))))
                   (RETURN (ENDDRAW))))
           EXPR)
  (DEFPROP SETSCALE (LAMBDA (XMN XMX YMN YMX)
                            (PROG NIL (SETQ XBOT (MINUS XMN))
                                  (SETQ XSCL
                                        (QUOTIENT REALWIDTH
                                                  (PLUS 1.0
                                                        (DIFFERENCE
                                                          XMX XMN))))
                                  (SETQ YBOT (MINUS YMN))
                                  (SETQ YSCL
                                        (QUOTIENT REALHEIGHT
                                                  (PLUS 1.0
                                                        (DIFFERENCE
                                                          YMX YMN))))))
           EXPR)
  (DEFPROP POSLABEL (LAMBDA (X Y MS)
                            (PROG2 (POS X Y)
                                   (LABELL MS)))
           EXPR)
  (DEFPROP POS (LAMBDA (X Y)
                       (AIVECT (SCALX X)
                               (SCALY Y)))
           EXPR)
  (DEFPROP SCALX (LAMBDA (X)
                         (SCALE X XBOT XSCL REALEFT))
           EXPR)
  (DEFPROP SCALE (LAMBDA (X XMN XMP START)
                         (PLUS START (FIX (PLUS (TIMES XMP
                                                       (PLUS X XMN))
                                                .5))))
           EXPR)
  (DEFPROP SCALY (LAMBDA (Y)
                         (SCALE Y YBOT YSCL REALBOTTOM))
           EXPR)
  (DEFPROP LINE (LAMBDA (X1 Y1 X2 Y2)
                        (PROG2 (POS X1 Y1)
                               (XDRAW X2 Y2)))
           EXPR)
  (DEFPROP XDRAW (LAMBDA (X Y)
                         (AVECT (SCALX X)
                                (SCALY Y)))
           EXPR)
  (DEFPROP LINE2
           (LAMBDA
             (MULT X1 Y1 X2 Y2)
             (PROG2 (LINE X1 Y1 X2 Y2)
                    (COND
                      ((NOT (GREATERP MULT 1.0))
                       NIL)
                      (T (PROG (DELTX DELTY DX DENOM DY)
                               (SETQ DELTX (DIFFERENCE X1 X2))
                               (SETQ DELTY (DIFFERENCE Y2 Y1))
                               (SETQ DENOM (SQRT (PLUS (TIMES DELTX 
                                                              DELTX)
                                                       (TIMES DELTY 
                                                              DELTY))))
                               (SETQ DX (TIMES EPSILON (QUOTIENT DELTY 
                                                              DENOM)))
                               (SETQ DY (TIMES EPSILON (QUOTIENT DELTX 
                                                              DENOM)))
                               (FOR NEW I := (2.0 MULT)
                                    DO
                                    (LINE (SETQ X1 (PLUS X1 DX))
                                          (SETQ Y1 (PLUS Y1 DY))
                                          (SETQ X2 (PLUS X2 DX))
                                          (SETQ Y2 (PLUS Y2 DY)))))))))
           EXPR)
STOP